home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / scm / arc_ext < prev    next >
Text File  |  1994-08-02  |  4KB  |  161 lines
  1. ;
  2. ; Archimedes specific includes
  3. ; Version 0.11  - ams {8|9->}/6/94
  4. ;
  5. ; DON'T even consider loading this into a non archi version of SCM
  6.  
  7. ;; be lazy..
  8. (define (graphics-mode)(mode 12))
  9.  
  10. ;; i'll assume we'll use 16 colour modes for text printing
  11. ;; by the time you are peering in here you can work it out probably :)
  12. (define t_black        0)
  13. (define t_red        1)
  14. (define t_green        2)
  15. (define t_yellow    3)
  16. (define t_blue        4)
  17. (define t_magenta   5)    
  18. (define t_cyan        6)
  19. (define t_white        7)
  20. (define t_flashing-bw 8)
  21. (define t_flashing-rc 9)
  22. (define t_flashing-gm 10)
  23. (define t_flashing-yb 11)
  24. (define t_flashing-by 12)
  25. (define t_flashing-mg 13)
  26. (define t_flashing-cr 14)
  27. (define t_flashing-wb 15)
  28.  
  29. ;
  30. ; Ok now some fast and somewhat wild ways of doing useful things with the
  31. ; vdu driver....
  32. ;
  33.  
  34.  
  35. ;pause every 75% of screen worth
  36. (define (paged-on)(begin (vdu 14) t))
  37.  
  38. ; or not...
  39. (define (paged-off)(begin (vdu 15) (not t)))
  40.  
  41. ; defines a text window.
  42. ; we wont check if its sensible...thats your problem ;-)
  43. ;
  44. (define (text-window x1 y1 x2 y2)
  45. (if (not (and (integer? x1)(integer? y1)(integer? x2)(integer? y2)))
  46.     (error "Arguments are not sensible!")
  47.     (begin
  48.           (cls)
  49.           (vdu 28)
  50.           (vdu x1)
  51.           (vdu y1)
  52.           (vdu x2)
  53.           (vdu y2)
  54.     )
  55. ))
  56.  
  57. (define (graphics-window x1 y1 x2 y2)
  58. (if (not (and (integer? x1)(integer? y1)(integer? x2)(integer? y2)))
  59.     (error "Arguments are not sensible!")
  60.     (begin
  61.           (vdu 24)
  62.           ;
  63.           ; _wrc2 does what you _might_ expect. (hint vdu 24,x1,y1,x2,y2
  64.           ; doesn't work, vdu 24,x1;y1;x2;y2; does.. )
  65.           ;
  66.           (_wrc2 x1)
  67.           (_wrc2 y1)
  68.           (_wrc2 x2)
  69.           (_wrc2 y2)
  70.     )
  71. ))
  72.  
  73. ; home-text-cursor
  74. (define (home-text-cursor)(vdu 30))
  75. (define (default-windows)(begin (vdu 26)(cls)(clg)))
  76. (define (default-colours)(vdu 20))
  77.  
  78. ;
  79. ; Others
  80. ;
  81. (define (move-by x y)
  82. (if (not (and (integer? x)(integer? y)))
  83.       (error "Arguments are not sensible!")
  84.       (plot 0 x y)
  85. ))
  86.  
  87. (define (point-by x y)
  88. (if (not (and (integer? x)(integer? y)))
  89.       (error "Arguments are not sensible!")
  90.       (plot 65 x y)
  91. ))
  92.  
  93. (define (draw-by x y)
  94. (if (not (and (integer? x)(integer? y)))
  95.       (error "Arguments are not sensible!")
  96.       (plot 1 x y)
  97. ))
  98.  
  99. (define (line x1 y1 x2 y2)
  100. (if (not (and (integer? x1)(integer? y1)(integer? x2)(integer? y2)))
  101.       (error "Arguments are not sensible!")
  102.       (begin
  103.               (move x1 y1)
  104.               (draw x2 y2)
  105.       )
  106. ))
  107.  
  108. (define (circle-fill x y rad)
  109. (if (not (and (integer? x)(integer? y)(integer? rad)))
  110.       (error "Arguments are not sensible!")
  111.       (begin
  112.               (plot 4 x y)
  113.               (plot 153 rad 0)
  114.       )
  115. ))
  116.  
  117. (define (rectangle-fill x y w h)
  118. (if (not (and (integer? x)(integer? y)(integer? w)(integer? h)))
  119.       (error "Arguments are not sensible!")
  120.       (begin
  121.               (move x y)
  122.               (plot 97 w h)
  123.       )
  124. ))
  125.  
  126. (define (rectangle x y w h)
  127. (if (not (and (integer? x)(integer? y)(integer? w)(integer? h)))
  128.       (error "Arguments are not sensible!")
  129.       (begin
  130.               (move x y)
  131.               (draw-by w 0)
  132.               (draw-by 0 h)
  133.               (draw-by (- 0 w) 0)
  134.               (draw-by 0 (- 0 h))
  135.       )
  136. ))
  137.  
  138. ;; getting more useful..( i hate figuring out these numbers..)
  139. ;; oh and if anyone with a RiscPC complains about mode 12 they can fix it
  140. ;; themselves (hehe).
  141. (define (graphics-mode)
  142. (begin
  143.       (mode 12)
  144.       (text-window 0 31 79 20)
  145.       (graphics-window 0 400 1024 1280)
  146.       (graphics-origin! 640 712)
  147. ))
  148.  
  149. ;;;
  150. ;;; turtles!  - see the demos in <scm$dir>.turtle..
  151. ;;; which as a few more useful definitions.
  152. ;;;
  153. (define (backward n)
  154.     (forward (- 0 n)))
  155.  
  156. (define (left n)
  157.     (turn n))
  158.  
  159. (define (right n)
  160.     (turn (- 0 n)))
  161.